home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / record.scm < prev    next >
Encoding:
Text File  |  1994-06-18  |  7.8 KB  |  226 lines
  1. ; "record.scm" record data types
  2. ; Written by David Carlton, carlton@husc.harvard.edu.
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ; Extensively Modified for SLIB by Aubrey Jaffer, jaffer@ai.mit.edu.
  7. ; May 17 1992, MAKE-RECORD-SUB-TYPE added by jaffer.
  8.  
  9. ; This more or less implements the records that are proposed for R5RS
  10. ; - unfortunately, all records created in this manner look like
  11. ; vectors.  I believe the original record proposal was made by
  12. ; Jonathan Rees.  This implementation defines some symbols other than
  13. ; those that are part of the record proposal - this wouldn't be a
  14. ; problem if Scheme had a module system, but it doesn't.
  15.  
  16. (require 'common-list-functions)
  17.  
  18. ; Tags to help identify rtd's.  (A record is identified by the rtd
  19. ; that begins it.)
  20. (define record:*rtd-tag* (cons 'rtd '()))
  21.  
  22. ; Checks to see if a list has any duplicates.  Also checks to see if
  23. ; it a list, for that matter.
  24. (define (record:has-duplicates? lst)
  25.   (cond
  26.    ((null? lst) #f)
  27.    ((not (pair? lst)) #t)
  28.    ((memq (car lst) (cdr lst)) #t)
  29.    (else (record:has-duplicates? (cdr lst)))))
  30.  
  31. ; Various accessor functions.  No error checking; if you call these,
  32. ; you should know that they will work.
  33. (define (record:rtd-tag x) (vector-ref x 0))
  34. (define (record:rtd-name rtd) (vector-ref rtd 1))
  35. (define (record:rtd-supers rtd) (vector-ref rtd 2))
  36. (define (record:rtd-fields rtd) (vector-ref rtd 3))
  37. ;; rtd-vfields is padded out to the length of the vector, which is 1
  38. ;; more than the number of fields
  39. (define (record:rtd-vfields rtd) (cons #f (record:rtd-fields rtd)))
  40. ;; rtd-length is the length of the vector.
  41. (define (record:rtd-length rtd) (vector-ref rtd 4))
  42.  
  43. (define (record:record-rtd x) (vector-ref x 0))
  44. (define (record:record-supers x) (vector-ref (vector-ref x 0) 2))
  45.  
  46. (define (record-predicate rtd)
  47.   (if (not (record:rtd? rtd))
  48.       (slib:error "record-predicate: invalid argument." rtd))
  49.   (vector-ref rtd 5))
  50.  
  51. (define (record-sub-predicate rtd)
  52.   (if (not (record:rtd? rtd))
  53.       (slib:error "record-predicate: invalid argument." rtd))
  54.   (vector-ref rtd 6))
  55.  
  56. (define (make-record-type type-name field-names)
  57.   (if (not (string? type-name))
  58.       (slib:error "make-record-type: non-string type-name argument."
  59.           type-name))
  60.   (if (or (record:has-duplicates? field-names)
  61.       (comlist:notevery symbol? field-names))
  62.       (slib:error "make-record-type: illegal field-names argument."
  63.           field-names))
  64.   (let* ((corrected-length (+ 1 (length field-names)))
  65.      (rtd (vector record:*rtd-tag*
  66.               type-name
  67.               '()
  68.               field-names
  69.               corrected-length
  70.               #f
  71.               #f)))
  72.     (vector-set! rtd 5
  73.          (lambda (x)
  74.            (and (vector? x)
  75.             (= (vector-length x) corrected-length)
  76.             (eq? (record:record-rtd x) rtd))))
  77.     (vector-set! rtd 6
  78.          (lambda (x)
  79.            (and (vector? x)
  80.             (>= (vector-length x) corrected-length)
  81.             (or (eq? (record:record-rtd x) rtd)
  82.                 (memq rtd (record:record-supers x)))
  83.             #t)))
  84.     rtd))
  85.  
  86. (define (make-record-sub-type type-name field-names rtd)
  87.   (if (not (string? type-name))
  88.       (slib:error "make-record-sub-type: non-string type-name argument."
  89.           type-name))
  90.   (if (not (record:rtd? rtd))
  91.       (slib:error "make-record-sub-type: non-rtd rtd argument."
  92.           rtd))
  93.   (let ((xfield-names (append (record:rtd-fields rtd) field-names)))
  94.     (if (or (record:has-duplicates? xfield-names)
  95.         (comlist:notevery symbol? field-names))
  96.     (slib:error "make-record-sub-type: illegal field-names argument."
  97.             field-names))
  98.     (let* ((corrected-length (+ 1 (length xfield-names)))
  99.        (rtd (vector record:*rtd-tag*
  100.             type-name
  101.             (cons rtd (record:rtd-supers rtd))
  102.             xfield-names
  103.             corrected-length
  104.             #f
  105.             #f)))
  106.       (vector-set! rtd 5
  107.            (lambda (x)
  108.              (and (vector? x)
  109.               (= (vector-length x) corrected-length)
  110.               (eq? (record:record-rtd x) rtd))))
  111.       (vector-set! rtd 6
  112.            (lambda (x)
  113.              (and (vector? x)
  114.               (>= (vector-length x) corrected-length)
  115.               (or (eq? (record:record-rtd x) rtd)
  116.                   (memq rtd (record:record-supers x))))))
  117.       rtd)))
  118.  
  119. ; Determines whether or not a certain object looks like an rtd.
  120. ; Doesn't do as much error-checking as it could, but it would be quite
  121. ; unlikely for somebody to accidentally fool this function.
  122. (define (record:rtd? object)
  123.   (and (vector? object)
  124.        ;; Could check for the exact value here, but then I'd have to
  125.        ;; keep changing this as I change the format of a rtd.  This
  126.        ;; is good enough to get the vector-ref to work.
  127.        (not (= (vector-length object) 0))
  128.        (eq? (record:rtd-tag object) record:*rtd-tag*)))
  129.  
  130. (define (record-constructor rtd . field-names)
  131.   (if (not (record:rtd? rtd))
  132.       (slib:error "record-constructor: illegal rtd argument." rtd))
  133.   (if (or (null? field-names)
  134.       (equal? field-names (record:rtd-fields rtd)))
  135.       (let ((record-length (- (record:rtd-length rtd) 1)))
  136.     (lambda elts
  137.       (if (= (length elts) record-length) #t
  138.           (slib:error "record-constructor: "
  139.               (record:rtd-name rtd)
  140.               ": wrong number of arguments."))
  141.       (apply vector rtd elts)))
  142.       (let ((record-vfields (record:rtd-vfields rtd))
  143.         (corrected-record-length (record:rtd-length rtd))
  144.         (field-names (car field-names)))
  145.     (if (or (record:has-duplicates? field-names)
  146.         (comlist:notevery (lambda (x) (memq x record-vfields))
  147.               field-names))
  148.         (slib:error
  149.          "record-constructor: invalid field-names argument."
  150.          (cdr record-vfields)))
  151.     (let ((field-length (length field-names))
  152.           (offsets
  153.            (map (lambda (field) (comlist:position field record-vfields))
  154.             field-names)))
  155.       (lambda elts
  156.         (if (= (length elts) field-length) #t
  157.         (slib:error "record-constructor: "
  158.                 (record:rtd-name rtd)
  159.                 ": wrong number of arguments."))
  160.         (let ((result (make-vector corrected-record-length)))
  161.           (vector-set! result 0 rtd)
  162.           (for-each (lambda (offset elt)
  163.               (vector-set! result offset elt))
  164.             offsets
  165.             elts)
  166.           result))))))
  167.  
  168. (define (record-accessor rtd field-name)
  169.   (if (not (record:rtd? rtd))
  170.       (slib:error "record-accessor: invalid rtd argument." rtd))
  171.   (let ((index (comlist:position field-name (record:rtd-vfields rtd)))
  172.     (corrected-length (record:rtd-length rtd)))
  173.     (if (not index)
  174.     (slib:error "record-accessor: invalid field-name argument."
  175.             field-name))
  176.     (lambda (x)
  177.       (if (and (vector? x)
  178.            (>= (vector-length x) corrected-length)
  179.            (or (eq? rtd (record:record-rtd x))
  180.            (memq rtd (record:record-supers x))))
  181.       #t
  182.       (slib:error "record-accessor: wrong record type." x "not" rtd))
  183.       (vector-ref x index))))
  184.  
  185. (define (record-modifier rtd field-name)
  186.   (if (not (record:rtd? rtd))
  187.       (slib:error "record-modifier: invalid rtd argument." rtd))
  188.   (let ((index (comlist:position field-name (record:rtd-vfields rtd)))
  189.     (corrected-length (record:rtd-length rtd)))
  190.     (if (not index)
  191.     (slib:error "record-modifier: invalid field-name argument."
  192.             field-name))
  193.     (lambda (x y)
  194.       (if (and (vector? x)
  195.            (>= (vector-length x) corrected-length)
  196.            (or (eq? rtd (record:record-rtd x))
  197.            (memq rtd (record:record-supers x))))
  198.       #t
  199.       (slib:error "record-modifier: wrong record type." x "not" rtd))
  200.       (vector-set! x index y))))
  201.  
  202. (define (record? obj)
  203.   (and (vector? obj)
  204.        (>= (vector-length obj) 1)
  205.        (record:rtd? (record:record-rtd obj))
  206.        (= (vector-length obj)
  207.       (record:rtd-length (record:record-rtd obj)))))
  208.  
  209. (define (record-type-descriptor record)
  210.   (if (not (record? record))
  211.       (slib:error "record-type-descriptor: invalid argument."
  212.           record))
  213.   (record:record-rtd record))
  214.  
  215. (define (record-type-name rtd)
  216.   (if (not (record:rtd? rtd))
  217.       (slib:error "record-type-name: invalid argument."))
  218.   (record:rtd-name rtd))
  219.  
  220. ; For this function, make a copy of the value returned in order to
  221. ; make it a bit harder for the user to screw things up.
  222. (define (record-type-field-names rtd)
  223.   (if (not (record:rtd? rtd))
  224.       (slib:error "record-type-field-names: invalid argument." rtd))
  225.   (append (record:rtd-fields rtd) '()))
  226.